unit unit_MD5Misc;

interface

uses Windows, SysUtils, Classes, Registry;

type
  TPlatform = (tpWinNT, tpWin2k, tpWin95, tpWin98);
  Tmd5Proc = procedure (StreamPos, StreamSize: Int64; var Cancel: Boolean) of Object;

function  MD5sum(Stream: TStream; Proc: Tmd5Proc): String;
function  SecToString(const Duration: Integer): String;
function  SwapChars(const Str: String; const OrigChar, NewChar: Char): String;
function  GetRegStringEntry(Root: HKey; Key, Value: String): String;
function  GetRegIntEntry(Root: HKey; Key, Value: String): Integer;
function  SetRegStringEntry(Root: HKey; Key, Value, Data: String; CanCreate: Boolean): Boolean;
function  SetRegIntEntry(Root: HKey; Key, Value: String; Data: Integer; CanCreate: Boolean): Boolean;
function  GetPlatform: TPlatform;
procedure GetFiles(Files: TStrings; const DirOrFile, Mask: String;
  const Recursive: Boolean; IncludeDirs: Boolean = FALSE);
function  FileVersionInfo(FileName: string): string;
{function GetAbsoluteFileName - returns absolute file name with full path}
function GetAbsoluteFileName(const FileName: AnsiString; const
    Root: AnsiString = ''): AnsiString;

implementation
//------------------------------------------------------------------------------
// function GetAbsoluteFileName
//   Returns absolute filename with full path
// Parameters:
//   const FileName: AnsiString - initial filename
//   const Root: AnsiString = '' - root file folder
// Result: AnsiString
//   Absolute filename, or initial filename if root folder not correct
//------------------------------------------------------------------------------
function GetAbsoluteFileName(const FileName: AnsiString; const
    Root: AnsiString = ''): AnsiString;
const
  ABS_PATH_COLON_POS = 2;
  ABS_PATH_COLON = ':';
var
  bAddRoot: Boolean;
begin
  Result := FileName;
  //
  // Check if path is absolute. If not, add root path to filename
  //
  bAddRoot := (FileName[ABS_PATH_COLON_POS] <> ABS_PATH_COLON) and
    (Root[ABS_PATH_COLON_POS] = ABS_PATH_COLON);
  if bAddRoot then
    Result := IncludeTrailingPathDelimiter(Root) + FileName;
end;

function MD5sum(Stream: TStream; Proc: Tmd5Proc): String;
const
  S11 = 7; S12 = 12; S13 = 17; S14 = 22;
  S21 = 5; S22 = 9;  S23 = 14; S24 = 20;
  S31 = 4; S32 = 11; S33 = 16; S34 = 23;
  S41 = 6; S42 = 10; S43 = 15; S44 = 21;
  CodeSaver1: Array[0..3] of dword = ($FFFFFF00, $FFFF00FF, $FF00FFFF, $00FFFFFF);
  CodeSaver2: Array[0..3] of dword = (0, 8, 16, 24);
var
  Int, loop, loop2, loop3: Integer;
  //Times_to_loop: Integer;
  Padding: String;
  A, B, C, D, AA, BB, CC, DD: dword;
  X: Array[0..15] of dword;
  MyBuffer: String;
  Start: Integer;
  Processing, Cancelled: Boolean;
  StreamSize: Int64; // Size of the stream in Bits


  Function MyStreamRead(S: TStream; var buffer; bytestoread: Integer): Integer;
  const
    buffersize = 128 * 1024;
  Var
    Data_End: LongInt;
  Begin
    If Length(MyBuffer) - Start < BytesToRead Then Begin
      Delete(MyBuffer, 1, Start);
      Start := 0;
      Data_End := Length(MyBuffer);
      SetLength(MyBuffer, Data_End + buffersize + 1);
      Data_End := Data_End + S.Read(MyBuffer[Data_End + 1], buffersize);
      SetLength(MyBuffer, Data_End);
      End;
    If Length(MyBuffer) + Start < bytestoread Then
      bytestoread := length(MyBuffer) - Start;
    Move(MyBuffer[Start + 1], Buffer, bytestoread);
    Start := Start + bytestoread;
    result := bytestoread;
  End;

  function REORDER(w: dword): dword;
  begin
    Result := w and $000000FF;
    Result := Result shl 8;
    w := w shr 8;
    Result := Result or (w and $000000FF);
    Result := Result shl 8;
    w := w shr 8;
    Result := Result or (w and $000000FF);
    Result := Result shl 8;
    w := w shr 8;
    Result := Result or (w and $000000FF);
  end;

  function ROTATE_LEFT(x, n: dword): dword;
  begin
    Result := (x shl n) or (x shr (32 - n));
  end;

  procedure FF(var a: dword; const b, c, d, x, s, ac: dword);
  begin
    a := ROTATE_LEFT(a + ((b and c) or ((not b) and d)) + x + ac, S) + b;
  end;

  procedure GG(var a: dword; const b, c, d, x, s, ac: dword);
  begin
    a := ROTATE_LEFT(a + (((b and d)or (c and (not d))) + x + ac), s) + b;
  end;

  procedure HH(var a: dword; const b, c, d, x, s, ac: dword);
  begin
    a := ROTATE_LEFT(a + ((b xor c xor d) + x + ac), s) + b;
  end;

  procedure II(var a: dword; const b, c, d, x, s, ac: dword);
  begin
    a := ROTATE_LEFT(a + ((c xor (b or (not d))) + x + ac), s) + b;
  end;

  Function GetPadding(S_Size: Int64): String;
  var
    Int: Integer;
    Padding: String;
    High, Low: dword;
    loop: Integer;
  Begin
    //High := (S_Size div 8) shr 29;
    //Low := (S_Size div 8) shl 3;
    High := S_Size shr 32;
    Low := S_Size;

    (* Step 1 - Append Padding Bits *)

    // Figure out how many bits need to be added
    // (Stream.Size * 8) = number of bits.
    Int := (((S_Size div 512) + 1) * 512) - S_Size;
    if Int < 65 then
      Int := Int + (512);

    // Subtract space for Size
    Int := Int - 64;

    // Check that everything's OK
    {if (Int + 64) mod 8 <> 0 then begin
      Result := 'Error #1 - Couldn''t calculate padding';
      exit;
      end;}

    // Translate from Bits to Bytes/Chars
    Int := Int div 8;

    SetLength(Padding, Int);
    Padding[1] := char(128);
    for loop := 2 to Int do
      Padding[loop] := char(0);

    // Check that it's still ok.
    {Int := (Stream.Size * 8) + (Length(Padding) * 8);
    Int := (Int + 64) mod 512;
    if Int <> 0 then begin
      Result := 'Error #2 - Padding Failed';
      exit;
      end;}

    (* Step 2 - Append Length *)

    Padding := Padding +
     Char(Low) +
     Char(Low Shr 8) +
     Char(Low Shr 16) +
     Char(Low Shr 24);
    Padding := Padding +
     Char(High) +
     Char(High Shr 8) +
     Char(High Shr 16) +
     Char(High Shr 24);

    // Check again
    {Int := Stream.Size + Length(Padding);
    if Int mod 64 <> 0 then begin
      Result := 'Error #3 - Append length failed';
      exit;
      end;}

    Result := Padding;
  End;

Begin

  MyBuffer:='';
  Start:=0;
  Result := '';
  StreamSize := 0;
  Processing := True;
  Cancelled := False;
  loop := 0;

  (* Step 1 - Initialize MD Buffer *)

  A := $67452301;
  B := $efcdab89;
  C := $98badcfe;
  D := $10325476;

  (* Step 2 - Process Message in 16-Word Blocks *)

  Stream.Seek(0, soFromBeginning);

  While Processing do
  Begin
    loop := loop + 1;
    if Assigned(Proc) and (loop mod 200 = 0) then
      Proc(StreamSize, Stream.Size, Processing);
    if not Processing then
      Cancelled := True;

    AA := A;
    BB := B;
    CC := C;
    DD := D;

    for loop2 := 0 to 15 do
    Begin
      Int := MyStreamRead(Stream, X[loop2], 4);
      StreamSize := StreamSize + (Int * 8);
      if Int < 4 then
      Begin
        if Padding = '' then
          Padding := GetPadding(StreamSize);

        for loop3 := Int to (4 - 1) do
        Begin
          X[loop2] := (X[loop2] and CodeSaver1[loop3]) or (ord(Padding[1]) shl CodeSaver2[loop3]);
          Delete(Padding, 1, 1);
        End; // for loop3

        if Length(Padding) <= ((16 - (loop2 + 1)) * 4) then
          Processing := False;
      End;
    End;

    // Round 1
    FF (a, b, c, d, x[ 0], S11, $d76aa478); // 1
    FF (d, a, b, c, x[ 1], S12, $e8c7b756); // 2
    FF (c, d, a, b, x[ 2], S13, $242070db); // 3
    FF (b, c, d, a, x[ 3], S14, $c1bdceee); // 4
    FF (a, b, c, d, x[ 4], S11, $f57c0faf); // 5
    FF (d, a, b, c, x[ 5], S12, $4787c62a); // 6
    FF (c, d, a, b, x[ 6], S13, $a8304613); // 7
    FF (b, c, d, a, x[ 7], S14, $fd469501); // 8
    FF (a, b, c, d, x[ 8], S11, $698098d8); // 9
    FF (d, a, b, c, x[ 9], S12, $8b44f7af); // 10
    FF (c, d, a, b, x[10], S13, $ffff5bb1); // 11
    FF (b, c, d, a, x[11], S14, $895cd7be); // 12
    FF (a, b, c, d, x[12], S11, $6b901122); // 13
    FF (d, a, b, c, x[13], S12, $fd987193); // 14
    FF (c, d, a, b, x[14], S13, $a679438e); // 15
    FF (b, c, d, a, x[15], S14, $49b40821); // 16

    // Round 2
    GG (a, b, c, d, x[ 1], S21, $f61e2562); // 17
    GG (d, a, b, c, x[ 6], S22, $c040b340); // 18
    GG (c, d, a, b, x[11], S23, $265e5a51); // 19
    GG (b, c, d, a, x[ 0], S24, $e9b6c7aa); // 20
    GG (a, b, c, d, x[ 5], S21, $d62f105d); // 21
    GG (d, a, b, c, x[10], S22, $2441453);  // 22
    GG (c, d, a, b, x[15], S23, $d8a1e681); // 23
    GG (b, c, d, a, x[ 4], S24, $e7d3fbc8); // 24
    GG (a, b, c, d, x[ 9], S21, $21e1cde6); // 25
    GG (d, a, b, c, x[14], S22, $c33707d6); // 26
    GG (c, d, a, b, x[ 3], S23, $f4d50d87); // 27
    GG (b, c, d, a, x[ 8], S24, $455a14ed); // 28
    GG (a, b, c, d, x[13], S21, $a9e3e905); // 29
    GG (d, a, b, c, x[ 2], S22, $fcefa3f8); // 30
    GG (c, d, a, b, x[ 7], S23, $676f02d9); // 31
    GG (b, c, d, a, x[12], S24, $8d2a4c8a); // 32

    // Round 3
    HH (a, b, c, d, x[ 5], S31, $fffa3942); // 33
    HH (d, a, b, c, x[ 8], S32, $8771f681); // 34
    HH (c, d, a, b, x[11], S33, $6d9d6122); // 35
    HH (b, c, d, a, x[14], S34, $fde5380c); // 36
    HH (a, b, c, d, x[ 1], S31, $a4beea44); // 37
    HH (d, a, b, c, x[ 4], S32, $4bdecfa9); // 38
    HH (c, d, a, b, x[ 7], S33, $f6bb4b60); // 39
    HH (b, c, d, a, x[10], S34, $bebfbc70); // 40
    HH (a, b, c, d, x[13], S31, $289b7ec6); // 41
    HH (d, a, b, c, x[ 0], S32, $eaa127fa); // 42
    HH (c, d, a, b, x[ 3], S33, $d4ef3085); // 43
    HH (b, c, d, a, x[ 6], S34, $4881d05);  // 44
    HH (a, b, c, d, x[ 9], S31, $d9d4d039); // 45
    HH (d, a, b, c, x[12], S32, $e6db99e5); // 46
    HH (c, d, a, b, x[15], S33, $1fa27cf8); // 47
    HH (b, c, d, a, x[ 2], S34, $c4ac5665); // 48

    // Round 4
    II (a, b, c, d, x[ 0], S41, $f4292244); // 49
    II (d, a, b, c, x[ 7], S42, $432aff97); // 50
    II (c, d, a, b, x[14], S43, $ab9423a7); // 51
    II (b, c, d, a, x[ 5], S44, $fc93a039); // 52
    II (a, b, c, d, x[12], S41, $655b59c3); // 53
    II (d, a, b, c, x[ 3], S42, $8f0ccc92); // 54
    II (c, d, a, b, x[10], S43, $ffeff47d); // 55
    II (b, c, d, a, x[ 1], S44, $85845dd1); // 56
    II (a, b, c, d, x[ 8], S41, $6fa87e4f); // 57
    II (d, a, b, c, x[15], S42, $fe2ce6e0); // 58
    II (c, d, a, b, x[ 6], S43, $a3014314); // 59
    II (b, c, d, a, x[13], S44, $4e0811a1); // 60
    II (a, b, c, d, x[ 4], S41, $f7537e82); // 61
    II (d, a, b, c, x[11], S42, $bd3af235); // 62
    II (c, d, a, b, x[ 2], S43, $2ad7d2bb); // 63
    II (b, c, d, a, x[ 9], S44, $eb86d391); // 64

    A := A + AA;
    B := B + BB;
    C := C + CC;
    D := D + DD;
  End; // While processing

  if Cancelled then
    Result := 'Cancelled'
  else
  Begin
    // Re-order ABCD
    A := REORDER(A);
    B := REORDER(B);
    C := REORDER(C);
    D := REORDER(D);

    Result := {Result
    + }inttohex(A, 8)
    + inttohex(B, 8)
    + inttohex(C, 8)
    + inttohex(D, 8);
  End;

  MyBuffer := '';
end;

function SecToString(const Duration: Integer): String;
{ Takes an integer number of seconds and returns a nice }
{ string of days, hours, mins and secs.                 }
var
  Min, Hour, Day, TempDuration: Integer;
  Word, Temp: String;
begin
  TempDuration := Duration;
  if TempDuration >= 86400 then begin
    Day := TempDuration div 86400;
    TempDuration := TempDuration - (86400 * Day);
    if Day = 1 then
      Word := ' Day, '
    else
      Word := ' Days, ';
    Temp := IntToStr(Day) + Word;
    end;
  if TempDuration >= 3600 then begin
    Hour := TempDuration div 3600;
    TempDuration := TempDuration - (3600 * Hour);
    if Hour = 1 then
      Word := ' Hour, '
    else
      Word := ' Hours, ';
    Temp := Temp + IntToStr(Hour) + Word;
    end;
  if TempDuration >= 60 then begin
    Min := TempDuration div 60;
    TempDuration := TempDuration - (60 * Min);
    if Min = 1 then
      Word := ' Min, '
    else
      Word := ' Mins, ';
    Temp := Temp + IntToStr(Min) + Word;
    end;
  Temp := Temp + IntToStr(TempDuration) + ' Sec';

  Result := Temp;
end;

function SwapChars(const Str: String; const OrigChar, NewChar: char): String;
begin
  Result := Str;

  if (Str <> '') and (OrigChar <> '') and (NewChar <> '') then
    while Pos(OrigChar, Result) <> 0 do
      Result[Pos(OrigChar, Result)] := NewChar;
end;

function GetRegStringEntry(Root: HKey; Key, Value: String): String;
//Returns '' if unsuccessful in any way.
begin
  Result := '';
  with TRegistry.Create do begin
    RootKey := Root;
    if OpenKey(Key, False) then
      try
        Result := ReadString(Value);
      finally
        Free;
      end
    else
      Free;
    end;
end;

function GetRegIntEntry(Root: HKey; Key, Value: String): Integer;
//Returns 0 if unsuccessful in any way.
begin
  Result := 0;
  with TRegistry.Create do begin
    RootKey := Root;
    if OpenKey(Key, False) then
      try
        Result := ReadInteger(Value);
      finally
        Free;
      end
    else
      Free;
    end;
end;

function SetRegStringEntry(Root: HKey; Key, Value, Data: String; CanCreate: Boolean): Boolean;
begin
  Result := True;
  with TRegistry.Create do begin
    RootKey := Root;
    if OpenKey(Key, CanCreate) then
      try
        WriteString(Value, Data);
      finally
        Free;
      end
    else begin
      Result := False;
      Free;
      end;
    end;
end;

function SetRegIntEntry(Root: HKey; Key, Value: String; Data: Integer; CanCreate: Boolean): Boolean;
begin
  Result := True;
  with TRegistry.Create do begin
    RootKey := Root;
    if OpenKey(Key, CanCreate) then
      try
        WriteInteger(Value, Data);
      finally
        Free;
      end
    else begin
      Result := False;
      Free;
      end;
    end;
end;

function GetPlatform: TPlatform;
var
  OSI: TOSVersionInfo;
begin
  OSI.dwOSVersionInfoSize := SizeOf(OSI);
  GetVersionEx(OSI);
  if OSI.dwPlatformId = VER_PLATFORM_WIN32_NT then begin // NT, 2k
    if OSI.dwMajorVersion <= 4 then //NT
      Result := tpWinNT
    else // 5 = 2000.
      Result := tpWin2k;
    end
  else begin // 95, 98
    if OSI.dwMinorVersion > 0 then
      Result := tpWin98
    else
      Result := tpWin95;
    end;
end;

procedure GetFiles(Files: TStrings; const DirOrFile, Mask: String;
  const Recursive: Boolean; IncludeDirs: Boolean = FALSE);
var
  SearchRecord: TSearchRec;
  Dir: String;
begin
  Dir := DirOrFile;

  if FileExists(Dir) then begin
    Files.Add(Dir);
    Exit;
    end;

  if Dir[Length(Dir)] <> '\' then
    Dir := Dir + '\';

  if not DirectoryExists(Dir) then
    Exit;

  FindFirst(Dir + Mask, faAnyFile{faDirectory}, SearchRecord);
  if (SearchRecord.Name <> '.') and (SearchRecord.Name <> '..') then
    if (SearchRecord.Attr and faDirectory = faDirectory) then
    begin
      if Recursive then
        GetFiles(Files, Dir + SearchRecord.Name, Mask, Recursive, IncludeDirs);
      if IncludeDirs then
        Files.Add(Dir + SearchRecord.Name);
    end
    else
      Files.Add(Dir + SearchRecord.Name);

  while FindNext(SearchRecord) = 0 do begin
    if (SearchRecord.Name <> '.') and (SearchRecord.Name <> '..') then
      if (SearchRecord.Attr and faDirectory = faDirectory) then
      begin
        if Recursive then
          GetFiles(Files, Dir + SearchRecord.Name, Mask, Recursive, IncludeDirs);
        if IncludeDirs then
          Files.Add(Dir + SearchRecord.Name);
      end
      else
        Files.Add(Dir + SearchRecord.Name);
    end;

  FindClose(SearchRecord);
end;

function FileVersionInfo(FileName: string): string;
// returns the version info for a file
var
  V1, V2, V3, V4: Word;
  VerInfoSize: DWORD;
  VerInfo: Pointer;
  VerValueSize: DWORD;
  VerValue: PVSFixedFileInfo;
  Dummy: DWORD;
begin
  Result := '';
  if not FileExists(Filename) then Exit;

  VerInfoSize := GetFileVersionInfoSize(PChar(FileName), Dummy);
  if VerInfoSize = 0 then
    // there is no version info
    Exit;

  GetMem(VerInfo, VerInfoSize);
  try
    if GetFileVersionInfo(PChar(FileName), 0, VerInfoSize, VerInfo) then
    begin
      VerQueryValue(VerInfo, '\', Pointer(VerValue), VerValueSize);
      with VerValue^ do
      begin
        V1 := dwFileVersionMS shr 16;
        V2 := dwFileVersionMS and $FFFF;
        V3 := dwFileVersionLS shr 16;
        V4 := dwFileVersionLS and $FFFF;
      end;
      Result := IntToStr(V1) + '.' + IntToStr(V2) + '.' + IntToStr(V3) + '.' +
        IntToStr(V4);
    end;
  finally
    FreeMem(VerInfo, VerInfoSize);
  end;
end;

end.
